COMMENT ⊗   VALID 00015 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 This file contains a set of transformations to transform
C00006 00003	 MAP
C00009 00004	 Equal and ASSQ
C00010 00005	 Numerical Stuff
C00012 00006	 DO
C00020 00007	 SETs
C00021 00008	 Arrays (Fixnum assumed)
C00023 00009	 Property lists
C00025 00010	 Useless features
C00026 00011	 Errors
C00027 00012	 Randoms
C00030 00013	 Character translations
C00032 00014	(setq *nopoint t)
C00033 00015	 Optimizers
C00034 ENDMK
C⊗;
;;; This file contains a set of transformations to transform
;;; Maclisp to Interlisp.

(declare (specials t)
	 (*lexpr %match))

(cond ((status features grindef))
      (t (fasload grinde fas dsk (mac lsp))
	 (fasload grind fas dsk (mac lsp))))

(cond ((not (and (boundp 'util-loaded)
		 (symeval 'util-loaded)))
       (fasload util fas dsk (aid lsp))))

(prog2 (remprop 'quote 'grindmacro) 
       (remprop 'quote 'grindpredict) 
;      (programspace 130.) 
       (predict t)
       (setq grind-standard-quote nil))

(setq function-names nil ?current-args nil)

(trans defun (*x)
 (let (?name ?args *body)
  (cond ((%match '(?name fexpr (?args) *body) *x)
	 (setq function-names (cons ?name function-names))
	 (code (defineq (?name (nlambda ?args *body)))))
        ((%match '(fexpr ?name (?args) *body) *x)
	 (setq function-names (cons ?name function-names))
         (code (defineq (?name (nlambda ?args *body)))))
	((%match '(?name ?args *body) *x)
	 (setq function-names (cons ?name function-names))
	 (setq ?current-args ?args)
      	 (code (defineq (?name (lambda ?args *body)))))
	(t (error '|Cannot Transform DEFUN to DEFINE| *x 'fail-act)))))

(macrodef chartrans (char trans)(defprop char trans transtring))

(transdef declare x (* . x))

(transdef comment x (* . x))

(setq macex-finally 'finally)

(defun concatenate (a b)
 (implode (append (explode a)(explode b))))

(defun finally () 
		  (sprinter ((lambda (mc mf)
   			     (list 'rpaqq mc (ncons (list 'fns '* mf))))
			     (concatenate (car current-file) 'coms)
			     (concatenate (car current-file) 'fns)))
		  (sprinter (list 'rpaqq (concatenate (car current-file)
					  	     'fns) function-names))
		  (terpri)
		  (princ '|STOP|)(terpri)
	 	  (setq function-names nil))

;;; MAP

(trans mapcar (?x *y)(cond ((= (length *y) 1)
			    (code (mapcar *y ?x)))
			   (t
			    (code (map2car *y ?x)))))
(trans mapc   (?x *y)(cond ((= (length *y) 1)
			    (code (mapc *y ?x)))
			   (t
			    (code (map2c *y ?x)))))

(transdef mapcan (x y) (mapconc y x nil))

;;; Equal and ASSQ

(transdef = (x y) (ieqp x y))

(transdef assq (x y)(assoc x y))

(transdef assoc (x y)(sassoc x y))

(transdef atom (x)(nlistp x y))

(transdef memq (x y)(memb x y))

(transdef delete (x y)(remove x y))

(transdef nreverse (x)(dreverse x))

(transdef intern (x) x)

(trans list* (?x *y) 
       (cond ((null (cdr *y))
	      (code (cons ?x . *y)))
	     (t (code (cons ?x (list* *y))))))

;;; Numerical Stuff

(transdef < x (ilessp . x))

(transdef > x (igreaterp . x))

(transdef * x (itimes . x))

(transdef - x(idifference  . x ))

(transdef + x(iplus  . x ))

(transdef // x(iquotient  . x ))

(transdef */$ x(ftimes  . x ))

(transdef +/$ x(fplus  . x ))

(transdef -/$ x(fdifference  . x ))

(transdef ///$ x(fquotient  . x ))

(transdef 1+ (x)(add1 x))

(transdef 1- (x)(idifference x 1))

(trans lessp (*x)
 (cond ((< (length *x) 3) (code (lessp *x)))
       (t ((lambda(?a ?b ?c)
	   (code (and (lessp ?a ?b)
		      (lessp ?b ?c))))
	   (car *x)(cadr *x)(caddr *x)))))

(transdef plusp (x) (lessp 0 x))
;;; DO

(defun trn-occurs (x l)
       (cond ((null l) ())
	     ((eq x l) t)
	     ((atom l) ())
	     (t (or (trn-occurs x (car l))
		    (trn-occurs x (cdr l))))))

(defmacro return-process (x)
	  `(cond (,x
		  (cond ((= (length ,x) 1)
			 (setq ,x `((return . ,,x))))
			(t 
			 (setq ,x
			       `((return (progn . ,,x)))))))
		 (t (setq ,x `((return ()))))))


(defmacro progn-process (x)
	  `(cond (,x
		  (cond ((= (length ,x) 1))
			(t 
			 (setq ,x
			       `((progn . ,,x))))))))


(trans do (*x)
       (cond ((or (%match '(((?step ?init (1+ ?step)))
			    ((= ?step ?end) *forms) *body)
			  *x)
		  (%match '(((?step ?init (1+ ?step)))
			    ((= ?end ?step) *forms) *body)
			  *x))
	      (cond ((trn-occurs ?step *forms)
		     (setq *forms `((setq ,?step (1+ ,?step)) . ,*forms))))
	      (return-process *forms)
	      (progn-process *body)
	      (cond ((numberp ?end)
		     (setq ?end (1- ?end)) 
		     (code (for ?step from ?init to ?end do *body finally *forms)))
		    (t 
		     (code (for ?step from ?init to (1- ?end) do *body finally *forms)))))
	     ((or (%match '(((?step ?init (1- ?step)))
			    ((= ?step ?end) *forms) *body)
			  *x)
		  (%match '(((?step ?init (1- ?step)))
			    ((= ?end ?step) *forms) *body)
			  *x))
	      (cond ((trn-occurs ?step *forms)
		     (setq *forms `((setq ,?step (1- ,?step)) . ,*forms))))
	      (return-process *forms)
	      (progn-process *body)
	      (cond ((numberp ?end)
		     (setq ?end (1+ ?end))
		     (code (for ?step from ?init to ?end by -1 do *body finally *forms)))
		    (t (code (for ?step from ?init to (1+ ?end) by -1 do *body finally *forms)))))
	     ((or (%match '(((?step ?init (1+ ?step)))
			    ((> ?step ?end) *forms) *body)
			  *x)
		  (%match '(((?step ?init (1+ ?step)))
			    ((< ?end ?step) *forms) *body)
			  *x))
	      (cond ((trn-occurs ?step *forms)
		     (setq *forms `((setq ,?step (1+ ,?step)) . ,*forms))))
	      (return-process *forms)
	      (progn-process *body)
	      (code (for ?step from ?init to ?end do *body finally *forms)))
	     ((or (%match '(((?step ?init (1- ?step)))
			    ((< ?step ?end) *forms) *body)
			  *x)
		  (%match '(((?step ?init (1- ?step)))
			    ((> ?end ?step) *forms) *body)
			  *x))
	      (cond ((trn-occurs ?step *forms)
		     (setq *forms `((setq ,?step (1- ,?step)) . ,*forms))))
	      (return-process *forms)
	      (progn-process *body)
	      (code (for ?step from ?init to ?end by -1 do *body finally *forms)))
	     (t (let ((?stepper
		       (for i ε (car *x) collect (car i)))
		      (?return-body ())
		      (?udummy ())
		      (?uinits ())
		      (?inits
		       (for i ε (car *x) collect (car i)))
		      (*init
		       (for i ε (car *x) collect (cadr i)))
		      (*next
		       (for i ε (car *x) collect (caddr i))) 
		      (?dummy
		       (for i ε (car *x) collect (gensym)) )
		      (?test (caadr *x))
		      (*return-body (cdadr *x))
		      (*body (cddr *x)))
		     (return-process *return-body)
		     (cond (?dummy 
			    (cond ((> (length ?dummy) 1)
				   (let ((*pairs  
					  (for i j ε ?stepper ?dummy conc (list i j))))
					(cond ((null (car ?stepper))
					       (setq ?stepper ())
					       (setq *init (ncons ()))
					       (setq ?inits ()))
					      (t (setq ?inits (cons 'setq *pairs))))
					(do ((x ?dummy (cdr x))
					     (y *next (cdr y))
					     (z *pairs (cddr z))
					     (a ())
					     (b ())
					     (c ()))
					    ((null x)
					     (setq ?udummy (nreverse a)
						   *next (nreverse b))
					     (cond ((= (length ?udummy) 1)
						    (setq ?uinits
							  `(setq  ,(cadr c) ,(car *next))))
						   (t (setq ?uinits `((lambda ,?dummy
									      (setq . ,(nreverse c)))
								      ,@*next)))))
					    (cond ((car y)
						   (push (car z) c)(push (cadr z) c)
						   (push (car x) a)
						   (push (car y) b))))
					(code ((lambda ?dummy
						       (prog ?stepper
							     ?inits
							     loop (cond (?test *return-body))
							     *body
							     ?uinits
							     (go loop)))
					       *init))))
				  (t 
				   (setq ?inits `(,(car ?stepper) ,(car *init)))
				   (setq ?uinits `(setq ,(car ?stepper)
							,(car *next)))
				   (code (prog ?inits
					       loop (cond (?test *return-body))
					       *body
					       ?uinits
					       (go loop))))))
			   (t (code 
			       (prog nil
				     loop (cond (?test *return-body))
				     *body
				     (go loop)))))))))))

;;; SETs

(trans setq (*x)
 (cond ((null (cddr *x)) (code (setq *x)))
       (t (let *setqs ← nil do
  	   (do ((i *x (cddr i)))
      	       ((null i)(setq *setqs (nreverse *setqs))
	       		(code (progn *setqs)))
      	       (setq *setqs (cons (list 'setq (car i)(cadr i)) *setqs)))))))   

;;; Arrays (Fixnum assumed)

(cond ((and (boundp '1-based-arrayp)
	    1-based-arrayp)
       (trans store ((?array *n) ?v)
	      (cond ((> (length *n) 1)
		     `(*seta ,?array ,@*n ,?v))
		    (t (code (seta ?array *n ?v)))))
       
       (trans array (?name ?type *dims)
	      (eval `(trans ,?name (*x)
			    (cond ((> (length *x) 1)
				   `(*elt  ,',?name ,@*x))
				  (t (code (elt ,?name *x))))))
	      (code (define-array ?name ?type *dims))))
      
      (t (trans store ((?array *n) ?v)
		(let ((*n (mapcar #'(lambda (x)
					    (cond ((numberp x)
						   (1+ x))
						  (t `(add1 ,x))))
				  *n)))
		     (cond ((> (length *n) 1)
			    `(*seta ,?array ,@*n ,?v))
			   (t (code (seta ?array *n ?v))))))
	 
	 (trans array (?name ?type *dims)
		(eval `(trans ,?name (*x)
			      (let ((*x (mapcar #'(lambda (x)
							  (cond ((numberp x)
								 (1+ x))
								(t `(add1 ,x))))
						*x)))
				   (cond ((> (length *x) 1)
					  `(*elt  ,',?name ,@*x))
					 (t (code (elt ,?name *x)))))))
		(code (define-array ?name ?type *dims)))))

;;; Property lists


(transdef get (x y)(getprop x y))

(transdef setplist (x y)(setproplist x y))

(transdef plist (x)(getproplist x))

(transdef defprop (x y z)(putprop 'x 'z 'y))

(transdef putprop (x y z)(putprop x z y))

(transdef disembodied-putprop (x y z)
 (d-putprop x z y))

(transdef disembodied-get (x y)
 (listget (cdr x) y))
;;; Useless features

(transdef sstatus x (* . x))

(transdef setsyntax x (* . x))


;;; Errors

(transdef error (x y z) (error y x nil))
;;; Randoms

(transdef explode (x)(unpack x))

(transdef implode (x)(pack x))

(transdef getchar (x n)(nthchar x n))

(transdef symeval (x)(evalv x))

(transdef ncons (x)(cons x nil))

(trans funcall (?x *y)(code (blkapply ?x (list *y))))
 
(transdef sprinter (x) (printdef x))

(transdef explodec (x)(unpack x))

(transdef exploden (x)(chcon x))

(transdef status x (* . x))

(transdef boundp (x) (errorset x))

(transdef define x (mdefine . x))

(transdef princ (x)(prin1 x))

(transdef tyipeek () (chcon1 (peekc)))

(transdef tyo (n)(prin1 (fcharacter n)))

(transdef tyi () (chcon1 (readc)))

(trans progv (?vars ?vals *body)
   (code (evala '(progn *body)(map2car ?vars ?vals 
			      (function (lambda (x y) (cons x y))) nil))))

(transdef esci-enb () (* esci-enb))

(trans set-version() ((lambda (?ver) 
		      (code (progn (setq version ?ver)
			    	   (setq lispversion 'INTERLISP))))
		      (cadr (status uread))))


(transdef require x (* . x))

(transdef pp x (mpp . x))

(trans arg (?a) (code (arg ?current-args ?a)))

(transdef *rset x nil)

(defprop prog1 t primitive)

(trans prog2 (?first ?second *rest)
  (code (progn ?first (prog1 ?second *rest))))

(transdef %char1 (x)(cond ((typep x 12) (fcharacter (chcon1 x)))))

;;; Character translations

(chartrans /α alpha)

(chartrans /β beta)

(chartrans /ε epsilon)

(chartrans /∂ partial)

(chartrans /λ lambda)

(chartrans /π pi)

(chartrans /% p-)

(chartrans // /%)

(chartrans /| /")

(chartrans /⊗ /&)
(setq *nopoint t)

(defun print-only () (putprop 'sprinter (get 'prin1 'lsubr) 'lsubr)
		     (setq linel 40))

(defun chrtrn fexpr (file)(setq linel 130.)(apply 'chartran file))

;;; Optimizers

(defmacro optimizer (name vars . forms)
	  `(defun (,name optimizer) ,vars . ,forms))

(optimizer progn (x)
	   (cond ((> (length x) 1) x)
		 (t (cadr x))))

(optimizer lambda (x)
	   (cond ((%match '((lambda (?x)
				    (setq ?z ?x))
			    ?y) x)
		  `(setq ,?z ,?y))
		 (t x)))